home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmpeval.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
15KB
|
372 lines
;;; CMPEVAL The Expression Dispatcher.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'system)
(export '(define-compiler-macro
undef-compiler-macro
define-inline-function))
(in-package 'compiler)
(si:putprop 'progn 'c1progn 'c1special)
(si:putprop 'progn 'c2progn 'c2)
(si:putprop 'si:structure-ref 'c1structure-ref 'c1)
(si:putprop 'structure-ref 'c2structure-ref 'c2)
(si:putprop 'structure-ref 'wt-structure-ref 'wt-loc)
(si:putprop 'si:structure-set 'c1structure-set 'c1)
(si:putprop 'structure-set 'c2structure-set 'c2)
(defun c1expr* (form info)
(setq form (c1expr form))
(add-info info (cadr form))
form)
(defun c1expr (form)
(setq form (catch *cmperr-tag*
(cond ((symbolp form)
(cond ((eq form nil) (c1nil))
((eq form t) (c1t))
((keywordp form)
(list 'LOCATION (make-info :type (object-type form))
(list 'VV (add-object form))))
((constantp form)
(let ((val (symbol-value form)))
(or (c1constant-value val nil)
(list 'LOCATION (make-info :type (object-type val))
(list 'VV (add-constant form))))))
(t (c1var form))))
((consp form)
(let ((fun (car form)))
(cond ((symbolp fun)
(c1symbol-fun fun (cdr form)))
((and (consp fun) (eq (car fun) 'lambda))
(c1lambda-fun (cdr fun) (cdr form)))
((and (consp fun) (eq (car fun) 'si:|#,|))
(cmperr "Sharp-comma-macro was found in a bad place."))
(t (cmperr "The function ~s is illegal." fun)))))
(t (c1constant-value form t)))))
(if (eq form '*cmperr-tag*) (c1nil) form))
(defvar *c1nil* (list 'LOCATION (make-info :type (object-type nil)) nil))
(defun c1nil () *c1nil*)
(defvar *c1t* (list 'LOCATION (make-info :type (object-type t)) t))
(defun c1t () *c1t*)
(defun c1symbol-fun (fname args &aux fd)
(cond ((setq fd (get fname 'c1special)) (funcall fd args))
((setq fd (c1local-fun fname))
(if (eq (car fd) 'call-local)
(let* ((info (make-info :sp-change t))
(forms (c1args args info)))
(let ((return-type (get-local-return-type (caddr fd))))
(when return-type (setf (info-type info) return-type)))
(let ((arg-types (get-local-arg-types (caddr fd))))
;;; Add type information to the arguments.
(when arg-types
(let ((fl nil))
(dolist** (form forms)
(cond ((endp arg-types) (push form fl))
(t (push (and-form-type
(car arg-types) form
(car args))
fl)
(pop arg-types)
(pop args))))
(setq forms (reverse fl)))))
(list 'call-local info (cddr fd) forms))
(c1expr (cmp-expand-macro fd fname args))))
((and (setq fd (get fname 'c1)) (inline-possible fname))
(funcall fd args))
((and (setq fd (get fname 'c1conditional))
(inline-possible fname)
(funcall (car fd) args))
(funcall (cdr fd) args))
((setq fd (macro-function fname))
(c1expr (cmp-expand-macro fd fname args)))
((setq fd (get fname 'compiler-macro))
(c1expr (cmp-eval `(funcall ',fd ',(cons fname args) nil))))
((and (setq fd (get fname 'si::structure-access))
(inline-possible fname)
;;; Structure hack.
(consp fd)
(si:fixnump (cdr fd))
(not (endp args))
(endp (cdr args)))
(case (car fd)
(vector (c1expr `(elt ,(car args) ,(cdr fd))))
(list (c1expr `(si:list-nth ,(cdr fd) ,(car args))))
(t (c1structure-ref1 (car args) (car fd) (cdr fd)))
)
)
((eq fname 'si:|#,|)
(cmperr "Sharp-comma-macro was found in a bad place."))
(t (let* ((info (make-info
:sp-change (null (get fname 'no-sp-change))))
(forms (c1args args info)))
(let ((return-type (get-return-type fname)))
(when return-type (setf (info-type info) return-type)))
(let ((arg-types (get-arg-types fname)))
;;; Add type information to the arguments.
(when arg-types
(do ((fl forms (cdr fl))
(fl1 nil)
(al args (cdr al)))
((endp fl)
(setq forms (reverse fl1)))
(cond ((endp arg-types) (push (car fl) fl1))
(t (push (and-form-type (car arg-types)
(car fl)
(car al))
fl1)
(pop arg-types))))))
(let ((arg-types (get fname 'arg-types)))
;;; Check argument types.
(when arg-types
(do ((fl forms (cdr fl))
(al args (cdr al)))
((or (endp arg-types) (endp fl)))
(check-form-type (car arg-types)
(car fl) (car al))
(pop arg-types))))
(case fname
(aref
(let ((etype (info-type (cadar forms))))
(when (or (and (eq etype 'string)
(setq etype 'character))
(and (consp etype)
(or (eq (car etype) 'array)
(eq (car etype) 'vector))
(setq etype (cadr etype))))
(setq etype
(type-and (info-type info) etype))
(when (null etype)
(cmpwarn
"Type mismatch was found in ~s."
(cons fname args)))
(setf (info-type info) etype))))
(si:aset
(let ((etype (info-type (cadar forms))))
(when (or (and (eq etype 'string)
(setq etype 'character))
(and (consp etype)
(or (eq (car etype) 'array)
(eq (car etype) 'vector))
(setq etype (cadr etype))))
(setq etype
(type-and (info-type info)
(type-and (info-type
(cadar (last forms)))
etype)))
(when (null etype)
(cmpwarn
"Type mismatch was found in ~s."
(cons fname args)))
(setf (info-type info) etype)
(setf (info-type (cadar (last forms)))
etype)
))))
(list 'call-global info fname forms)))
)
)
(defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t)))
(setq args (c1args args info))
(setq lambda-expr (c1lambda-expr lambda-expr))
(add-info info (cadr lambda-expr))
(list 'call-lambda info lambda-expr args)
)
(defun c2expr (form)
(if (eq (car form) 'call-global)
(c2call-global (caddr form) (cadddr form) nil (info-type (cadr form)))
(apply (get (car form) 'c2) (cddr form))))
(defun c2expr* (form)
(let* ((*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2expr form)
(wt-label *exit*))
)
(defun c2expr-top (form top &aux (*vs* 0) (*max-vs* 0) (*level* (1+ *level*))
(*reservation-cmacro* (next-cmacro)))
(wt-nl "{register object *base" (1- *level*) "=base;")
(base-used)
(wt-nl "{register object *base=V" top ";")
(wt-nl "register object *sup=vs_base+VM" *reservation-cmacro* ";")
(if *safe-compile*
(wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
(wt-nl "vs_check;"))
(wt-nl) (reset-top)
(c2expr form)
(push (cons *reservation-cmacro* *max-vs*) *reservations*)
(wt-nl "}}")
)
(defun c2expr-top* (form top)
(let* ((*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2expr-top form top)
(wt-label *exit*)))
(defun c1progn (forms &aux (fl nil))
(cond ((endp forms) (c1nil))
((endp (cdr forms)) (c1expr (car forms)))
(t (let ((info (make-info)))
(dolist (form forms)
(setq form (c1expr form))
(push form fl)
(add-info info (cadr form)))
(setf (info-type info) (info-type (cadar fl)))
(list 'progn info (reverse fl))
)))
)
;;; Should be deleted.
(defun c1progn* (forms info)
(setq forms (c1progn forms))
(add-info info (cadr forms))
forms)
(defun c2progn (forms)
;;; The length of forms may not be less than 1.
(do ((l forms (cdr l)))
((endp (cdr l))
(c2expr (car l)))
(declare (object l))
(let* ((*value-to-go* 'trash)
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2expr (car l))
(wt-label *exit*)
))
)
(defun c1args (forms info)
(mapcar #'(lambda (form) (c1expr* form info)) forms))
;;; Structures
(defun c1structure-ref (args)
(if (and (not (endp args))
(not (endp (cdr args)))
(consp (cadr args))
(eq (caadr args) 'quote)
(not (endp (cdadr args)))
(symbolp (cadadr args))
(endp (cddadr args))
(not (endp (cddr args)))
(si:fixnump (caddr args))
(endp (cdddr args)))
(c1structure-ref1 (car args) (cadadr args) (caddr args))
(let ((info (make-info)))
(list 'call-global info 'si:structure-ref (c1args args info)))))
(defun c1structure-ref1 (form name index &aux (info (make-info)))
;;; Explicitly called from c1expr and c1structure-ref.
(list 'structure-ref info (c1expr* form info) (add-symbol name) index))
(defun c2structure-ref (form name-vv index
&aux (*vs* *vs*) (*inline-blocks* 0))
(let ((loc (car (inline-args (list form) '(t)))))
(unwind-exit (list 'structure-ref loc name-vv index)))
(close-inline-blocks)
)
(defun wt-structure-ref (loc name-vv index)
(if *safe-compile*
(wt "structure_ref(" loc ",VV[" name-vv "]," index ")")
(wt "(" loc ")->str.str_self[" index "]")))
(defun c1structure-set (args &aux (info (make-info)))
(if (and (not (endp args))
(not (endp (cdr args)))
(consp (cadr args))
(eq (caadr args) 'quote)
(not (endp (cdadr args)))
(symbolp (cadadr args))
(endp (cddadr args))
(not (endp (cddr args)))
(si:fixnump (caddr args))
(not (endp (cdddr args)))
(endp (cddddr args)))
(let ((x (c1expr (car args)))
(y (c1expr (cadddr args))))
(add-info info (cadr x))
(add-info info (cadr y))
(setf (info-type info) (info-type (cadr y)))
(list 'structure-set info x
(add-symbol (cadadr args)) ;;; remove QUOTE.
(caddr args) y))
(list 'call-global info 'si:structure-set (c1args args info))))
(defun c2structure-set (x name-vv index y
&aux locs (*vs* *vs*) (*inline-blocks* 0))
(setq locs (inline-args (list x y *c1t*) '(t t t)))
(setq x (car locs))
(setq y (cadr locs))
(if *safe-compile*
(wt-nl "structure_set(" x ",VV[" name-vv "]," index "," y ");")
(wt-nl "(" x ")->str.str_self[" index "]= " y ";"))
(unwind-exit y)
(close-inline-blocks)
)
(defun c1constant-value (val always-p)
(cond
((eq val nil) (c1nil))
((eq val t) (c1t))
((si:fixnump val)
(list 'LOCATION (make-info :type 'fixnum)
(list 'FIXNUM-VALUE (add-object val) val)))
((characterp val)
(list 'LOCATION (make-info :type 'character)
(list 'CHARACTER-VALUE (add-object val) (char-code val))))
((typep val 'long-float)
(list 'LOCATION (make-info :type 'long-float)
(list 'LONG-FLOAT-VALUE (add-object val) val)))
((typep val 'short-float)
(list 'LOCATION (make-info :type 'short-float)
(list 'SHORT-FLOAT-VALUE (add-object val) val)))
(always-p
(list 'LOCATION (make-info :type (object-type val))
(list 'VV (add-object val))))
(t nil)))
(defmacro si::define-compiler-macro (name vl &rest body)
`(progn (si:putprop ',name
(caddr (si:defmacro* ',name ',vl ',body))
'compiler-macro)
',name))
(defun si::undef-compiler-macro (name)
(remprop name 'compiler-macro))
(defvar *compiler-temps*
'(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9))
(defmacro si:define-inline-function (name vars &body body)
(let ((temps nil)
(*compiler-temps* *compiler-temps*))
(dolist (var vars)
(if (and (symbolp var)
(not (si:memq var '(&optional &rest &key &aux))))
(push (or (pop *compiler-temps*)
(gentemp "TMP" (find-package 'compiler)))
temps)
(error "The parameter ~s for the inline function ~s is illegal."
var name)))
(let ((binding (cons 'list (mapcar
#'(lambda (var temp) `(list ',var ,temp))
vars temps))))
`(progn
(defun ,name ,vars ,@body)
(si:define-compiler-macro ,name ,temps
(list* 'let ,binding ',body))))))